;; Copyright 2011 ALICE A.I. Foundation

;(require :agraph) 
(require :datetime)

;(in-package :triple-store-user)


;(load "c:/gruff/gruff.fasl")
;#+ide
;(defun show-store ()
;   (ab::display-store :select-window t))

(load "files.cl")

(defparameter *substring_error* "")
(defparameter *root* nil)
(defparameter *catcnt* 0)
(defparameter *dupcnt* 0)
(defparameter *filemap* nil)
(defparameter *file-stream-map* nil)
(defvar *progress-state* 0)

(defun start-progress () (setq *progress-state* 0))
(defun progress (x limit)
  (if* (> (/ (* 100 x) limit) *progress-state*) then (format t ".") (setq *progress-state* (+ 1 *progress-state*))))
(defun end-progress () (format t "100%~%"))
  
(defconstant *day-names*
    '("Monday" "Tuesday" "Wednesday"
      "Thursday" "Friday" "Saturday"
      "Sunday"))

(defun timestamp () 
(let* ((list (multiple-value-list (get-decoded-time)))
       (date (nth 3 list))
       (month (nth 4 list))
       (year (nth 5 list)))
(format nil "~a/~a/~a"  month date year)))

(defun copyright (ostream)
(format ostream "<!-- -->~%")
(format ostream "<!-- Free software (c) 2011 ALICE A.I. Foundation.   -->~%")
(format ostream "<!-- This program is open source code released under -->~%")
(format ostream "<!-- the terms of the GNU General Public License     -->~%")
(format ostream "<!-- as published by the Free Software Foundation.   -->~%")
(format ostream "<!-- Complies with AIML 1.0 Tag Set Specification -->~%")
(format ostream "<!-- as adopted by the ALICE A.I. Foundation.  -->~%")
(format ostream "<!-- Last modified ~a -->~%" (timestamp))
(format ostream "<!-- -->~%")
)

(defun file-string (path)
(start-progress)
(let* ((in (open path :if-does-not-exist nil)) (str "") (sz (/ (file-length in) 10)) (cnt 0))
  (when in
    (loop for line = (read-line in nil)
         while line do ;(format t "~a~%" line) 
           (progress cnt sz) (setq cnt (+ 1 cnt))
           (setq str (concatenate 'string str line)))
    (close in))
  (end-progress)
  str))


;(defun file-string (path)
;  "Sucks up an entire file from PATH into a freshly-allocated string"
;  (with-open-file (s path) 
;    (format t "File length ~a~%" (file-length s))
;    (let* ((len (file-length s))
;           (data (make-string len)))
;      (read-sequence data s)
;     (format t "Data length ~a~%" (length data))
;      data)))
;      (values data (read-sequence data s)))))

(defun substring (string start &optional end) 
  (if* (and end (< end start)) then
    (format t "~a < ~a in ~a~%" start end string)
    *substring_error*
  elseif (and end (< end (length string))) then (subseq string start end) 
  else (subseq string start)))

(defun extract-contents (stag etag category default)
  "Get the contents between the start tag stag and then end tag etag."
;(declare (optimize (speed 3) (debug 0) (safety 0)))
(let ((contents nil))
  (if* (and (search stag category) (search etag category))
  then
  (let ((start (+ (search stag category) (length stag)))
        (end (search etag category)))
       (if* (and (numberp start) (numberp end) (> start end)) then (format t "for tag ~a start > end: ~a~%" stag category)
       else 
       (setq contents (substring category start end))
       (string-trim '(#\Tab #\Space #\Newline) contents)))
  else
  default)))

(defun extract-that (category)
  (extract-contents "<that>" "</that>" category "*"))

(defun extract-pattern (category)
  (extract-contents "<pattern>" "</pattern>" category "*"))

(defun extract-template (category)
  (extract-contents "<template>" "</template>" category "Blank template"))

(defun extract-topics (filename)
"The top-level function to read AIML from a file, looks for <topic> and <category>"
(format t "Extract topics: ~a~%" filename)
(let* ((*aiml* nil)
      (cnt 0)
      (*aiml* (file-string filename))
      (tuple nil)  
      (tuples nil)  
      (result nil))
(start-progress)
(loop while (or (search "<category>" *aiml*) (search "<topic name=\"" *aiml*)) do
 (progress cnt 8000) (setq cnt (+ 1 cnt))
 (if* (and (search "<topic name=\"" *aiml*) (search "<category>" *aiml*) (< (search "<topic name=\"" *aiml*) (search "<category>" *aiml*)))
    then
    (let* ((start (search "<topic name=\"" *aiml*))
           (topicstart (+ start (length "<topic name=\"")))
           (suffix (substring *aiml* topicstart))
           (topicend (search "\">" suffix))
           (topicname (substring suffix 0 topicend))
           (end (search "</topic>" *aiml*))
           (categories (substring *aiml* (+ start (length "<topic name=\"") (length topicname) (length "\">")) end)))
    (setq tuples (extract-categories categories topicname filename))
    (setq result (append tuples result))
    (setq *aiml* (substring *aiml* (+ end (length "</topic>")))))
  elseif (search "<category>" *aiml*) then 
    (let ((start (+ (search "<category>" *aiml*) (length "<category>")))
          (end (search "</category>" *aiml*)))
       (setq category (substring *aiml* start end))
       (setq tuple (list (extract-pattern category) (extract-that category) "*" (extract-template category) filename))
;       (format t "~a~%" tuple)
       (setq result (cons tuple result))
       (setq *aiml* (substring *aiml* (+ end (length "</category>")))))
  else
    (setq *aiml* (substring *aiml* 1))))
(end-progress)
result))
  

(defun extract-categories (aiml topicname filename)
"Extract category tuples (pattern that topic template filename) from some AIML in a file (possibly inside a <topic>)"
;(format t "Extract categories:~%")
(let ((result nil)
      (tuple nil)
      (category nil)
      (cnt 0)
      (pattern nil)
      (that nil)
      (template nil))
(loop while (search "<category>" aiml) do
    (let ((start (+ (search "<category>" aiml) (length "<category>")))
          (end (search "</category>" aiml)))
       (setq category (substring aiml start end))
       (setq tuple (list (extract-pattern category) (extract-that category) topicname (extract-template category) filename))
;       (format t "~a~%" tuple)
       (setq result (cons tuple result))
       (setq aiml (substring aiml (+ end (length "</category>"))))))
result))

(defun split-by-one-space (string)
    "Returns a list of substrings of string
divided by ONE space each.
Note: Two consecutive spaces will be seen as
if there were an empty string between them."
    (loop for i = 0 then (1+ j)
          as j = (position #\Space string :start i)
          collect (substring string i j)
          while j))

(defun remove-nils-and-blanks (l)
(cond ((null l) nil)
     ((null (car l)) (remove-nils-and-blanks (cdr l)))
     ((string= (car l) "") (remove-nils-and-blanks (cdr l)))
     ((string= (car l) " ") (remove-nils-and-blanks (cdr l)))
     (t (cons (car l) (remove-nils-and-blanks (cdr l))))))


(defun split-by-spaces (string) 
  (remove-nils-and-blanks (split-by-one-space string)))

(defun intern-list (l)
  (cond ((null l) nil)
        (t (cons (intern (car l)) (intern-list (cdr l))))))

(defun pattern-path (category)
   (let ((pattern (nth 0 category))
         (that (nth 1 category))
         (topic (nth 2 category)))
(intern-list
   (append (split-by-spaces pattern) '("<that>") (split-by-spaces that) '("<topic>") (split-by-spaces topic)))))

(defun randomize-templates (t1 t2)
  (if* (string= "<random>" (substring t1 0 (length "<random>"))) then 
       (concatenate 'string "<random><li>" t2 "</li>" (substring t1 (length "<random>")))
   else
       (concatenate 'string "<random><li>" t1 "</li><li>" t2 "</li></random>")))

(defun add-triples-from-path (path node template)
"Store AIML in a semantic web database"
(format t "atfp: ~a ~a~%" path node)
   (if* path then
      (let* ((word (intern-resource (symbol-name (car path))))
            (nextnode nil)
            (nextnodelist (select (?x) (q (?? node) (?? word) ?x))))
        (format t "next node list:~a~%" nextnodelist)         
        (if* nextnodelist then (setq nextnode (intern-resource (caar nextnodelist)))
             else (setq nextnode (intern-resource (symbol-name (gensym "node")))))
        (format t "next node=~a~%" nextnode)
        (add-triple node word nextnode)
        (add-triples-from-path (cdr path) nextnode template))
     else (add-triple node (intern-resource "<template>") (intern-resource template))))
 
(defun add-path (path fullpath node pattern that topic template filename stream)
  "Store AIML in a graph using hash tables"
;  (format t "add-path ~a ~a ~a ~a ~a ~a ~a~%" path node pattern that topic template filename)
  (if* (null path) then 
       (if* (gethash 'template node) 
            then  
;            (format t "duplicate~%")
            (setq *dupcnt* (+ 1 *dupcnt*))
	    (format stream "Duplicate category ~a ~a ~a ~a = ~a ~a ~a ~a"  pattern that topic filename (gethash 'pattern node) (gethash 'that node) (gethash 'topic node) (gethash 'filename node))
	    (if* (string= (gethash 'template node) template) 
                 then 
                 (format stream " [identical template]~%")
                 else 
  	         (format stream " ~a != ~a~%" (substring template 0 8) (substring (gethash 'template node) 0 8))
;                 (setf (gethash 'template node) (randomize-templates (gethash 'template node) template))
;                 (setf (gethash 'filename node) filename)
            )
	    else
;            (format t "Non duplicate~%")
	    (setf (gethash 'path node) fullpath)
	    (setf (gethash 'node node) node)
	    (setf (gethash 'template node) template)
	    (setf (gethash 'pattern node) pattern)
	    (setf (gethash 'that node) that)
	    (setf (gethash 'topic node) topic)
	    (setf (gethash 'filename node) filename))
       else ; not null path
;       (format t "Non null path~%")
       (let* ((word (car path))
	      (nextnode (gethash word node)))
	 (if* (null nextnode) then 
	      (setq nextnode (make-hash-table))
	      (setf (gethash word node) nextnode))
	 (add-path (cdr path) fullpath nextnode pattern that topic template filename stream))))

(defun cdr-match (path nextnode)
"corecursive function for AIML pattern matching"
(let ((result nil))
;(format t "cdr match ~a ~a~%" path (loop for key being the hash-keys of nextnode collect key))
     (loop until (or (null path) (setf result (match (cdr path) nextnode))) do
        (setq path (cdr path)))
;    (format t "Result C = ~a~%" result)
     result))

(defun match (path node)
"AIML matching algorithm"
(let ((result nil))
;(format t "match ~a ~a ~a~%" path (loop for key being the hash-keys of node collect key) (gethash (car path) node))
(if* (and (null path) (gethash 'template node)) then node
;(list 
;(gethash 'pattern node)
;(gethash 'that node)
;(gethash 'topic node)
;(gethash 'template node)
;(gethash 'filename node))
   elseif (null path) then nil
   elseif (and (gethash '_ node) (setf result (cdr-match path (gethash '_  node)))) then
;     (format t "Result 1 = ~a~%" result)
     result
   elseif (and (gethash (car path) node) (setf result (match (cdr path) (gethash (car path) node)))) then
;     (format t "Result 2 = ~a~%" result)
     result
   elseif (and (gethash '* node) (setf result (cdr-match  path (gethash '* node)))) then
;     (format t "Result 3 = ~a~%" result)
     result
   else nil)))
 
(defun dotriples ()
"Test storing AIML in a semantic web database"
  (let ((cnt 0))
  (create-triple-store "c:/aiml-pandorabots-utilities/graphmaster.db")
  (setq *root* (intern-resource "root"))
  (setq categories (extract-topics "test.aiml"))
  (setq len (length categories))
  (loop for x in categories do 
;  (format t "~a/~a. ~a~%" cnt len x)
  (add-triples-from-path (pattern-path x) *root* (nth 3 x))
  (if* (= 0 (mod cnt 100)) then (index-new-triples))
  (setq cnt (+ 1 cnt)))))

(defun write-category (x stream)
  (format stream "<category><pattern>~a</pattern>~%" (nth 0 x))
  (if* (not (string= (nth 1 x) "*")) then (format stream "<that>~a</that>~%" (nth 1 x)))
  (format stream "<template>~a</template>~%" (nth 3 x))
  (format stream "</category>~%"))

(defun write-topic-category (x stream) 
;  (format t "Write topic-category ~a ~a~%" x stream)
  (if* (not (string= (nth 2 x) "*")) then 
     (format stream "<topic name=\"~a\">~%" (nth 2 x))
     (write-category x stream)
     (format stream "</topic>~%")
     else 
    (write-category x stream)
))

(defun write-categories (categories filename)
  (with-open-file (stream filename :direction :output :if-exists :supersede)
		  (format stream "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>~%<aiml version=\"1.0\">~%")
		  (copyright stream)
		  (loop for x in categories do (write-topic-category x stream))
 (format stream "</aiml>~%")))



(defun doit ()
  (setq *root* (make-hash-table))
  (setq *filemap* (make-hash-table))
  (setq *file-stream-map* (make-hash-table))
  (setq *cantcnt* 0)
  (setq *dupcnt* 0)
  (with-open-file (stream "duplicates.txt" :direction :output :if-exists :supersede)
		  (let ((categories nil) (len 0) (allfiles nil))
;	    (loop for f in '("test.aiml") do
;  	       (let ((cnt 0) (pathname f) (internf (intern f)))
		    (loop for f in *aiml_files* do
			  (let ((cnt 0) (pathname (concatenate 'string "c:/alice/aiml-en-us-foundation-alice/" f)) (internf (intern f)))
                            (start-progress)
			    (setq categories (extract-topics pathname))
			    (setq len (length categories))
                            (setf (gethash internf *filemap*) nil)
			    (format t "add paths from ~a~%" f)
			    (loop for x in categories do 
				  (progress cnt (length categories)) (setq cnt (+ 1 cnt))
				  (setq *catcnt* (+ 1 *catcnt*))
				  (add-path (pattern-path x) (pattern-path x) *root*  (nth 0 x) (nth 1 x) (nth 2 x) (nth 3 x) internf stream))
                            (end-progress)
                            (setf allfiles (loop for key being the hash-keys of *filemap* collect key))
                            (loop for k in allfiles do 
				  (setf (gethash k *file-stream-map*) 
					(open (concatenate 'string "aiml/" (symbol-name k)) :direction :output
                                   :if-exists :supersede))
 		                  (format (gethash k *file-stream-map*) "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>~%<aiml version=\"1.0\">~%")
                                  (copyright (gethash k *file-stream-map*)))
                            (format t "Allfiles = ~a internf = ~a gethash = ~a~%" allfiles internf (length (gethash internf *filemap*)))
                            (traverse-graph *root*)
                            (loop for k in allfiles do 
   	                        (format (gethash k *file-stream-map*) "</aiml>~%")
				(close (gethash k *file-stream-map*)))
                            
;			    (loop for g in allfiles do 
;				  (write-categories (gethash g *filemap*) (concatenate 'string "aiml/" (symbol-name g))))
))))
  (format t "~a categories ~a duplicates at ~a~%" *catcnt* *dupcnt* (timestamp)))


(defun traverse-graph (node)
   (if* (null node) then (format t "Null node~%")
    elseif (gethash 'template node) then 
       (write-topic-category (list (gethash 'pattern node) (gethash 'that node) (gethash 'topic node) (gethash 'template node) (gethash 'filename node)) 
          (gethash (gethash 'filename node) *file-stream-map*))
    else (loop for k in (loop for key being the hash-keys of node collect key) do
            (traverse-graph (gethash k node)))))

(defun path-to-string (path)
  (cond ((null path) "")
        (t (concatenate 'string (symbol-name (car path)) " " (path-to-string (cdr path))))))

(defun find-shadows (node stream)
  (let ((result nil))
;   (format t "shadows ~a~%" node)
    (if* (null node) 
         then (format t "Null node~%")
	 elseif (gethash 'template node) 
         then 
	 (setf result (match (gethash 'path node) *root*))
;	 (format t "Result = ~a~%" (gethash 'path result))
	 (if* (not (equal node (gethash 'node result))) then
		   (format t "Expected = ~a: ~a Got = ~a: ~a~%" (gethash 'filename node) (path-to-string (gethash 'path node)) (gethash 'filename result) (path-to-string (gethash 'path result)))
		   (format stream "Expected = ~a: ~a Got = ~a: ~a~%" (gethash 'filename node) (path-to-string (gethash 'path node)) (gethash 'filename result) (path-to-string (gethash 'path result)))
         )
	 else (loop for k in (loop for key being the hash-keys of node collect key) do
		    (find-shadows (gethash k node) stream)))))

(defun test () 
  (with-open-file (stream "shadows.txt" :direction :output :if-exists :supersede)
(find-shadows *root* stream)))
  
(defun ask (s)
   (match (intern-list (split-by-spaces (concatenate 'string s " <that> X <topic> X"))) *root*))

